PC Answers 1995 May

home *** CD-ROM | disk | FTP | other *** search

/ PC Answers 1995 May / PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso / vbits / code / mee / vbdao / visdata / dataform.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1994-10-06 | 21.3 KB | 746 lines

VERSION 2.00 Begin Form fDataForm BackColor = &H00C0C0C0& ClientHeight = 2520 ClientLeft = 1815 ClientTop = 3000 ClientWidth = 5700 Height = 2925 Icon = 0 Left = 1755 LinkTopic = "Form2" MDIChild = -1 'True ScaleHeight = 2520 ScaleWidth = 5700 Tag = "Dynaset" Top = 2655 Width = 5820 Begin CommonDialog CMD1 Left = 4800 Top = 1800 End Begin PictureBox StatBox Align = 2 'Align Bottom BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 270 Left = 0 ScaleHeight = 282.462 ScaleMode = 0 'User ScaleWidth = 5710.27 TabIndex = 6 Top = 2250 Width = 5700 Begin Data Data1 Connect = "" DatabaseName = "" Exclusive = 0 'False Height = 270 Left = 0 Options = 0 ReadOnly = 0 'False RecordSource = "" Top = 0 Width = 5475 End End Begin VScrollBar cScrollBar Height = 2085 LargeChange = 3000 Left = 7665 SmallChange = 300 TabIndex = 15 Top = 630 Visible = 0 'False Width = 255 End Begin PictureBox cFields BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 1065 Left = 0 ScaleHeight = 1056.479 ScaleMode = 0 'User ScaleWidth = 7600.262 TabIndex = 10 TabStop = 0 'False Top = 630 Width = 7605 Begin TextBox cFieldData BackColor = &H00FFFFFF& DataSource = "Data1" ForeColor = &H00000000& Height = 285 Index = 0 Left = 1665 TabIndex = 13 Top = 0 Visible = 0 'False Width = 3255 End Begin CheckBox cFieldCheck BackColor = &H00C0C0C0& DataSource = "Data1" Height = 282 Index = 0 Left = 1680 TabIndex = 12 Top = 735 Visible = 0 'False Width = 3270 End Begin PictureBox cFieldPicture DataSource = "Data1" Height = 282 Index = 0 Left = 1680 ScaleHeight = 255 ScaleWidth = 3240 TabIndex = 11 Top = 315 Visible = 0 'False Width = 3270 End Begin Label cFieldName BackColor = &H00C0C0C0& ForeColor = &H00000000& Height = 255 Index = 0 Left = 105 TabIndex = 14 Top = 0 Visible = 0 'False Width = 1575 End End Begin PictureBox FieldHeader Align = 1 'Align Top BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 300 Left = 0 ScaleHeight = 300 ScaleMode = 0 'User ScaleWidth = 5703.402 TabIndex = 7 Top = 330 Width = 5700 Begin Label FieldValueLabel BackColor = &H00C0C0C0& Caption = " Value:" Height = 252 Left = 1680 TabIndex = 9 Top = 30 Width = 2652 End Begin Label FieldHdrLabel BackColor = &H00C0C0C0& Caption = "Field Name:" Height = 252 Left = 120 TabIndex = 8 Top = 30 Width = 1212 End End Begin PictureBox TopPic Align = 1 'Align Top BackColor = &H00C0C0C0& BorderStyle = 0 'None Height = 330 Left = 0 ScaleHeight = 330 ScaleWidth = 5700 TabIndex = 0 Top = 0 Width = 5700 Begin CommandButton CancelAddBtn Caption = "C&ancel" Height = 330 Left = 0 TabIndex = 17 Top = 0 Visible = 0 'False Width = 960 End Begin CommandButton RefreshBtn Caption = "&Refresh" Height = 330 Left = 3780 TabIndex = 16 Top = 0 Width = 960 End Begin CommandButton FindBtn Caption = "&Find" Height = 330 Left = 2835 TabIndex = 5 Top = 0 Width = 960 End Begin CommandButton CloseBtn Cancel = -1 'True Caption = "&Close" Height = 330 Left = 4725 TabIndex = 4 Top = 0 Width = 960 End Begin CommandButton DeleteBtn Caption = "&Delete" Height = 330 Left = 1890 TabIndex = 3 Top = 0 Width = 960 End Begin CommandButton AddBtn Caption = "&Add" Height = 330 Left = 0 TabIndex = 2 Top = 0 Width = 960 End Begin CommandButton UpdateBtn Caption = "&Update" Height = 330 Left = 945 TabIndex = 1 Top = 0 Width = 960 End End '============================================================================ ' This is a fairly generic form that can be used in most cases with any ' table. I am sorry if it is confusing. There is a lot of paths to ' keep track on with adding, editing, browsing, deleting records ' on populated as well as empty tables. I have added flags where I ' felt there was no other way to achieve the correct functionality. ' I am sure that you can improve this form greatly with a little ' time and understanding of your spcific needs. There is also some ' recursion that could be trapped but hopefully, the form will be ' a good starting point for any data control app. '============================================================================ Dim FldArr() As Control Dim FDS As dynaset Dim FBM As String 'form global bookmark Dim numFlds As Integer Dim CurrField As Integer Dim CurrRec As Long Dim TotRec As Long Dim JustUsedFind As Integer 'flag for find function Dim fResizing As Integer 'flag to avoid resize recursion Dim CancelFlag As Integer 'flag to cancel an addnew Dim FldTop As Integer Const EM_NOTHING = 0 Const EM_EDIT = 1 Const EM_ADDNEW = 2 Const FT_TRUEFALSE = 1 Const FT_BYTE = 2 Const FT_INTEGER = 3 Const FT_LONG = 4 Const FT_CURRENCY = 5 Const FT_SINGLE = 6 Const FT_DOUBLE = 7 Const FT_DATETIME = 8 Const FT_STRING = 10 Const FT_BINARY = 11 Const FT_MEMO = 12 Const YES = 6 Const MSGBOX_TYPE = 4 + 48 Sub AddBtn_Click () On Error GoTo AddErr Data1.Recordset.AddNew Data1.Caption = "New Record" CancelAddBtn.Visible = True AddBtn.Visible = False If Data1.Recordset.RecordCount <> 0 Then FBM = Data1.Recordset.Bookmark FldArr(0).SetFocus End If GoTo AddEnd AddErr: MsgBox Error$ Resume AddEnd AddEnd: End Sub Sub CancelAddBtn_Click () On Error Resume Next CancelFlag = True If Len(FBM) > 0 Then Data1.Recordset.Bookmark = FBM End If If FDS.RecordCount > 0 Then SetRecNum End If End Sub Sub cFieldData_KeyPress (Index As Integer, KeyAscii As Integer) 'go to next field on an enter keypress If KeyAscii = 13 Then KeyAscii = 0 SendKeys "{Tab}" End If End Sub Sub cFieldPicture_Click (Index As Integer) 'this toggles the size of a picture control 'so it mat be viewed or compressed If cFieldPicture(Index).Height <= 280 Then cFieldPicture(Index).AutoSize = True Else cFieldPicture(Index).AutoSize = False cFieldPicture(Index).Height = 280 End If End Sub Sub cFieldPicture_DblClick (Index As Integer) On Error GoTo PicErr CMD1.Filter = "Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.ico|Metafiles (*.wmf)|*.wmf|All Files (*.*)|*.*" CMD1.DialogTitle = "Select a Picture File to Load" CMD1.FilterIndex = 1 CMD1.Action = 1 If Len(CMD1.Filename) > 0 Then cFieldPicture(Index).Picture = LoadPicture(CMD1.Filename) End If GoTo PicEnd PicErr: MsgBox Error$ Resume PicEnd PicEnd: End Sub Sub CloseBtn_Click () On Error Resume Next Unload Me End Sub Sub cScrollBar_Change () Dim t As Integer t = cScrollBar If (t - FldTop) Mod 300 = 0 Then cFields.Top = t Else cFields.Top = ((t - FldTop) \ 300) * 300 + FldTop End If End Sub Sub Data1_Error (DataErr As Integer, Response As Integer) If DataErr = 481 Then 'throw away bad picture error Response = 0 Else MsgBox "Data error event hit err:" & Error$(DataErr) End If End Sub Sub Data1_RePosition () Dim bm As String Dim ds As dynaset If Data1.Recordset.RecordCount = 0 And Data1.EditMode <> 2 Then Call AddBtn_Click Exit Sub End If If JustUsedFind = True Then Set ds = Data1.Recordset.Clone() bm = Data1.Recordset.Bookmark ds.MoveFirst CurrRec = 1 While ds.Bookmark <> bm CurrRec = CurrRec + 1 ds.MoveNext Wend JustUsedFind = False End If SetRecNum End Sub Sub Data1_Validate (Action As Integer, Save As Integer) On Error GoTo ValErr If CancelFlag Then Save = False CancelFlag = False Exit Sub End If 'first check for a move from an addnew or edit record If Action < 5 Then If Save = True Then 'data changed If Data1.EditMode = EM_ADDNEW Then If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then TotRec = TotRec + 1 Else Save = False End If Else If MsgBox("Commit Changes?", MSGBOX_TYPE) <> YES Then Save = False 'loose changes End If End If End If SetRecNum End If Select Case Action Case 1 'First CurrRec = 1 Case 2 'Previous If CurrRec = 1 Then Beep If CurrRec <> 1 Then CurrRec = CurrRec - 1 Case 3 'Next If CurrRec = TotRec Then Beep If CurrRec <> TotRec Then CurrRec = CurrRec + 1 Case 4 'Last CurrRec = TotRec Case 5 'AddNew 'do nothing Case 6 'Update 'moved to the updatebtn_click event code Case 7 'Delete TotRec = TotRec - 1 SetRecNum Case 8 'set the flag for use in the reposition event JustUsedFind = True Case 9 'BookMark 'do nothing" Case 10 'Close If Save = True Then If MsgBox("Commit Changes before Closing?", MSGBOX_TYPE) <> YES Then Save = False End If End If End Select GoTo ValEnd ValErr: ShowError Resume ValEnd ValEnd: End Sub Sub DeleteBtn_Click () On Error GoTo DELErr If MsgBox("Delete Current Record?", MSGBOX_TYPE) = YES Then Data1.Recordset.Delete Data1.Recordset.MoveNext FldArr(0).SetFocus End If GoTo DelEnd DELErr: MsgBox Error$ Resume DelEnd DelEnd: End Sub Sub FindBtn_Click () On Error GoTo FindErr Dim bm As String, findstr As String findstr = InputBox("Enter Search Expression:") If Len(findstr) = 0 Then Exit Sub If Data1.Recordset.RecordCount > 0 Then bm = Data1.Recordset.Bookmark End If Data1.Recordset.FindFirst findstr 'return to old record if no match was found If Data1.Recordset.NoMatch And Len(bm) > 0 Then Data1.Recordset.Bookmark = bm End If GoTo FindEnd FindErr: MsgBox Error$ Resume FindEnd FindEnd: FldArr(0).SetFocus End Sub Sub Form_Load () Dim ds2 As dynaset Dim Start, Finish On Error GoTo LoadErr '------------------------------------------------------- 'this is where the data control properties get 'set from whatever source they are coming from 'in this case, it is form1 controls '------------------------------------------------------- If gstDataType <> SQLDB Then Data1.DatabaseName = gCurrentDB.Name End If Data1.Connect = gCurrentDB.Connect 'determine if a table name or sql statement is used If gfFromSQL = True Then If Len(gstDynaString) = 0 Then Data1.RecordSource = fSQL.cSQLStatement Else Data1.RecordSource = gstDynaString End If Caption = "Dynaset: SQL Statement" Else If VDMDI.cPassThru.Visible = True And VDMDI.cPassThru = 1 Then Data1.RecordSource = "select * from " & StripOwner((fTables.cTableList)) Else Data1.RecordSource = fTables.cTableList End If Caption = "Dynaset: " & UCase(fTables.cTableList) End If '------------------------------------------------------- If VDMDI.cPassThru.Visible = True And VDMDI.cPassThru = 1 Then Data1.Options = VBDA_SQLPASSTHROUGH End If Start = TimeGetTime() Data1.Refresh CurrRec = 1 Set ds2 = Data1.Recordset.Clone() If ds2.BOF = False Then ds2.MoveLast TotRec = ds2.RecordCount Else TotRec = 0 End If ds2.Close Width = 5805 LoadFields Me.Show FldArr(0).SetFocus SetRecNum Finish = TimeGetTime() If VDMDI.PrefShowPerf.Checked Then MsgBox TotRec & " rows found in " & (Finish - Start) / 1000 & " seconds!", 48 End If GoTo LoadEnd LoadErr: If Err = 3061 Then Beep MsgBox "Parameterized Queries not available with Data Control!" Else ShowError End If Unload Me Resume LoadEnd LoadEnd: End Sub Sub Form_Resize () On Error Resume Next If fResizing = True Then Exit Sub Dim h As Integer, i As Integer Dim totw As Integer fResizing = True If WindowState <> 1 And cFieldName(0).Visible = True Then 'not minimized 'make sure the form is lined up on a field h = Height If (h - 1320) Mod 300 <> 0 Then Height = ((h - 1320) \ 300) * 300 + 1320 End If 'resize the status bar StatBox.Top = Height - 650 'resize the scrollbar cScrollBar.Height = StatBox.Top - (FieldHeader.Top - FieldHeader.Height) - 600 cScrollBar.Left = Width - 360 If FDS.Fields.Count > 10 Then cFields.Width = Width - 260 totw = cScrollBar.Left - 20 Else cFields.Width = Width - 20 totw = Width - 50 End If FieldHeader.Width = Width - 20 'widen the fields if possible For i = 0 To FDS.Fields.Count - 1 cFieldName(i).Width = .3 * totw FldArr(i).Left = cFieldName(i).Width + 20 If Data1.Recordset.Fields(i).Type > 9 Then FldArr(i).Width = .7 * totw - 270 End If Next FieldValueLabel.Left = FldArr(0).Left End If Data1.Width = StatBox.Width fResizing = False End Sub Function GetFieldWidth (t As Integer) 'determines the form control width 'based on the field type Select Case t Case FT_TRUEFALSE GetFieldWidth = 850 Case FT_BYTE GetFieldWidth = 650 Case FT_INTEGER GetFieldWidth = 900 Case FT_LONG GetFieldWidth = 1100 Case FT_CURRENCY GetFieldWidth = 1800 Case FT_SINGLE GetFieldWidth = 1800 Case FT_DOUBLE GetFieldWidth = 2200 Case FT_DATETIME GetFieldWidth = 2000 Case FT_STRING GetFieldWidth = 3250 Case FT_MEMO GetFieldWidth = 3250 Case Else GetFieldWidth = 3250 End Select End Function Sub LoadFields () Dim t As dynaset Dim ds As String 'temp dynaset name string Dim ft As Integer Dim i As Integer On Error GoTo LoadFieldsErr Set FDS = Data1.Recordset Set t = FDS 'load the controls on the dynaset form numFlds = t.Fields.Count ReDim FldArr(numFlds) As Control cFieldName(0).Visible = True ft = t.Fields(0).Type If ft = FT_TRUEFALSE Then Set FldArr(0) = cFieldCheck(0) ElseIf ft = FT_BINARY Then Set FldArr(0) = cFieldPicture(0) Else Set FldArr(0) = cFieldData(0) End If FldArr(0).Visible = True FldArr(0).Top = 0 FldArr(0).Width = GetFieldWidth(ft) If ft = FT_STRING Then FldArr(0).MaxLength = t.Fields(0).Size FldArr(0).TabIndex = 0 On Error Resume Next For i = 1 To t.Fields.Count - 1 cFields.Height = cFields.Height + 300 Load cFieldName(i) cFieldName(i).Top = cFieldName(i - 1).Top + 300 cFieldName(i).Visible = True ft = t.Fields(i).Type If ft = FT_TRUEFALSE Then Load cFieldCheck(i) Set FldArr(i) = cFieldCheck(i) ElseIf ft = FT_BINARY Then Load cFieldPicture(i) Set FldArr(i) = cFieldPicture(i) Else Load cFieldData(i) Set FldArr(i) = cFieldData(i) End If FldArr(i).Top = FldArr(i - 1).Top + 300 FldArr(i).Visible = True FldArr(i).Width = GetFieldWidth(ft) FldArr(i).TabIndex = i If ft = FT_STRING Then FldArr(i).MaxLength = t.Fields(i).Size Next On Error GoTo LoadFieldsErr 'resize main window cFields.Top = FieldHeader.Top + FieldHeader.Height FldTop = cFields.Top cScrollBar = FldTop If i <= 10 Then Height = i * 300 + 1500 cScrollBar.Visible = False Else Height = 4500 Width = Width + 260 cScrollBar.Visible = True cScrollBar.Min = FldTop cScrollBar.Max = FldTop - (i * 300) + 3000 End If 'display the field names For i = 0 To t.Fields.Count - 1 cFieldName(i) = UCase(t.Fields(i).Name) & ":" Next 'bind the controls On Error Resume Next 'bind even if table is empty For i = 0 To t.Fields.Count - 1 FldArr(i).DataField = t.Fields(i).Name Next GoTo LoadFieldsEnd LoadFieldsErr: MsgBox Error$ Resume LoadFieldsEnd LoadFieldsEnd: End Sub Sub MoveBtn_Click (Index As Integer) On Error GoTo moveerr Dim bm As String If Not Data1.Recordset.BOF And Not Data1.Recordset.EOF Then bm = Data1.Recordset.Bookmark End If Select Case Index Case 0 If Len(findval) > 0 Then Data1.Recordset.FindFirst findval Else Data1.Recordset.MoveFirst End If Case 1 If Len(findval) > 0 Then Data1.Recordset.FindPrevious findval Else Data1.Recordset.MovePrevious End If Case 2 If Len(findval) > 0 Then Data1.Recordset.FindNext findval Else Data1.Recordset.MoveNext End If Case 3 If Len(findval) > 0 Then Data1.Recordset.FindLast findval Else Data1.Recordset.MoveLast End If End Select 'return to old record if no match was found If Data1.Recordset.NoMatch And Len(bm) > 0 Then Data1.Recordset.Bookmark = bm End If GoTo moveend moveerr: MsgBox Error$ Resume moveend moveend: FldArr(0).SetFocus End Sub Sub RefreshBtn_Click () On Error GoTo RefErr Data1.Refresh GoTo RefEnd RefErr: ShowError Resume RefEnd RefEnd: End Sub Sub SetRecNum () If Data1.EditMode <> 2 Then If Data1.Recordset.BOF = True Then Data1.Caption = "Record BOF of " & TotRec ElseIf Data1.Recordset.EOF = True Then Data1.Caption = "Record EOF of " & TotRec Else Data1.Caption = "Record " & CurrRec & " of " & TotRec End If End If 'reset buttons if needed If Data1.EditMode <> 2 Then CancelAddBtn.Visible = False AddBtn.Visible = True End If End Sub Sub UpdateBtn_Click () On Error GoTo UpdErr Dim addflag As Integer addflag = Data1.EditMode If Data1.EditMode = EM_ADDNEW Then If MsgBox("Save New Record?", MSGBOX_TYPE) = YES Then Data1.Recordset.Update TotRec = TotRec + 1 End If Else If MsgBox("Commit Changes?", MSGBOX_TYPE) = YES Then Data1.Recordset.Update End If End If If addflag = 2 Then FDS.MoveLast End If GoTo UpdEnd UpdErr: ShowError Resume UpdEnd UpdEnd: End Sub